The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/tpb4_src.zip/DIRS.PAS

Pascal/Delphi Source File | 1988-09-13 | 13KB | 444 lines

{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
  Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault

  Last modified  ::  3-24-88 8:46 pm
}

{$R-}                             {Range checking off}
{$B-}                             {Boolean complete evaluation off}
{$S-}                             {Stack checking off}
{$I+}                             {I/O checking on}
{$N-}                             {No numeric coprocessor}

Unit Dirs;

Interface

Uses
  TPCrt, Dos, Globals, Core1,
  Core2, Extract;


function compress_fn(name : DosFileName) : DosFileName;

function correct_fn(Str : DosFileName) : DosFileName;

procedure ReadDir(var entries     : Word;
                  var space_used  : LongInt;
                  var first       : FilePtr);

procedure LibReadDir(var entries     : Word;
                     var space_used  : LongInt;
                     var first       : FilePtr);

procedure ArcReadDir(var entries     : Word;
                     var space_used  : LongInt;
                     var first       : FilePtr);

function Expand_Filename(tfname : DosFileName) : DosFileName;

function Equal_names(test, target : DosFileName) : Boolean;


  {==========================================================================}


Implementation


  procedure InsertFile(fname           : name_array;
                       index           : Word;
                       size            : LongInt;
                       attrib          : Byte;
                       var entries     : Word;
                       var total       : LongInt;
                       var first       : FilePtr);
    { Insert a new file name into an alphabetic list }

  var
    space           : LongInt;
    F,                            { File name entry being created }
    This, last      : FilePtr;    { Followers for insertion }
    fn              : DosFileName;

  begin
    fn := '           ';          { Initialize string }
    Move(fname, fn[1], 11);       { Move name into place }
    Insert('.', fn, 9);
    last := nil;
    This := first;
    while (This <> nil) and (This^.fname < fn) do
      begin
        last := This;
        This := This^.next
      end;
    space := size shr 3;
    if (size mod 8) <> 0 then
      Inc(space);
    if This^.fname <> fn then
      begin
        Inc(entries);
        total := total+space;
        New(F);
        F^.fname := fn;
        F^.index := index;
        F^.fsize := size;
        F^.attrib := attrib;
        F^.next := This;
        if last = nil then
          first := F
        else
          last^.next := F
      end
    else if (This^.fname = fn) and (This^.fsize < size) then
      begin
        total := total+space;
        space := This^.fsize shr 3;
        if (This^.fsize mod 8) <> 0 then
          Inc(space);
        total := total-space;
        This^.fsize := size
      end
  end;


  function compress_fn(name : DosFileName) : DosFileName;
    { Strip hi bits and remove all blanks from file name }

  var
    i               : Integer;

  begin
    for i := 1 to Length(name) do
      name[i] := Chr($7F and Ord(name[i]));
    i := Pos(' ', name);
    while i > 0 do
      begin
        Delete(name, i, 1);
        i := Pos(' ', name)
      end;
    compress_fn := name
  end;



  function correct_fn(Str : DosFileName) : DosFileName;
    { Correct possible errors in file name }

  var
    i, J            : Integer;

  begin
    i := 1;                       { Remove blanks and invalid characters }
    while i <= Length(Str) do
      if Str[i] in [' ', '*', ',', ':', ';', '=', '?', '+', '[', ']', '/'] then
        Delete(Str, i, 1)
      else
        Inc(i);
    while (Str <> '') and (Str[1] = '.') do { Remove leading '.' }
      Delete(Str, 1, 1);
    i := Pos('.', Str);           { Remove redundant '.' }
    J := 1;
    while J <= Length(Str) do
      if (Str[J] = '.') and (J > i) then
        Delete(Str, J, 1)
      else
        Inc(J);
    i := Pos('.', Str);
    if i = 0                      { Ensure name has '.' }
    then
      begin
        Str := Copy(Str, 1, 8);   { Ensure file name <= 8 characters }
        if Length(Str) > 0 then
          Str := Str+'.'
      end
    else
      Str := Copy(Str, 1, min(8, Pred(i)))+'.'+Copy(Str, Succ(i), min(3, Length(Str)-i));
    correct_fn := Str
  end;



  procedure ReadDir(var entries     : Word;
                    var space_used  : LongInt;
                    var first       : FilePtr);
    { Create an alphabetized list of files in the current file area }

  var
    This            : FilePtr;
    file_name       : name_array;
    mask            : StrPr;
    FileSize        : LongInt;
    DirInfo         : SearchRec;
    Attribute       : Word;


    procedure fillrec;

    var
      i, x            : Integer;
      work            : string[12];

    begin
      work := DirInfo.name;
      FillChar(file_name, 11, ' ');
      x := 1;
      i := 1;
      while (work[i] <> Chr(0)) and (i <= Length(work)) do
        begin
          if work[i] = '.' then
            begin
              x := 9;
              Inc(i);
            end
          else
            begin
              file_name[x] := Ord(work[i]);
              Inc(x);
              Inc(i);
            end;
        end;
      with DirInfo do
        begin
          FileSize := size div 128;
          if Chr(file_name[1]) <> ' ' then
            InsertFile(file_name, 0, FileSize, attr, entries, space_used, first);
        end;
    end;

  begin                           {ReadDir}
    new_dir := True;
    space_used := 0;
    while first <> nil do         { Clean out any old directory list }
      begin
        This := first;
        first := first^.next;     { Go to next on chain }
        Dispose(This)             { Reclaim space }
      end;
    DirEntries := 0;
    mask := '????????.???'+Chr(0);
    if ((user_rec.access >= 250) and (mode <> sysop_mode)) or ((not remote_copy)
      and (mode <> sysop_mode)) then
      Attribute := 39
    else
      Attribute := 33;
    SetSect(SetName);
    FindFirst(mask, Attribute, DirInfo);
    if DosError = 0 then
      begin
        fillrec;                  {enter data into linked list}
        repeat
          FindNext(DirInfo);
          if DosError = 0 then fillrec;
        until DosError <> 0;
      end;
    free_space := diskfree(0) div 1024; {current directory}
    SetSect(HomName)
  end;



  procedure LibReadDir(var entries     : Word;
                       var space_used  : LongInt;
                       var first       : FilePtr);
    { Read library directory }

  var
    i, off, result  : Integer;
    This            : FilePtr;
    LibBlock        : array[0..3] of EntryBlock;

  begin
    SetSect(SetName);
    Assign(libr_file, LibReq);
    {$I-}
    Reset(libr_file, 1) {$I+} ;
    if (IoResult = 0) and (FileSize(libr_file) > 0) then
      begin
        while first <> nil do     { Clean out any old directory list }
          begin
            This := first;
            first := first^.next; { Go to next on chain }
            Dispose(This)         { Reclaim space }
          end;
        {$I-}
        BlockRead(libr_file, LibBlock, 128, result) {$I+} ;
        in_library := (IoResult = 0);
        i := 1;
        while in_library and (i < 11) do
          if LibBlock[0].fname[i] = $20 then
            Inc(i)
          else
            in_library := False;
        in_library := in_library and (LibBlock[0].status = 0);
        if in_library then
          begin
            new_dir := True;
            space_used := 0;
            LibEntries := 0;
            for i := 1 to Pred(LibBlock[0].fsize shl 2) do
              begin
                off := i mod 4;
                if off = 0 then
                  BlockRead(libr_file, LibBlock, 128, result);
                with LibBlock[off] do
                  if status < $FE then
                    InsertFile(fname, index, fsize, 0, entries, space_used, first)
              end
          end
      end
    else
      begin
        WriteLn(com, 'Error opening Lbr File ', LibReq, '.');
        new_dir := False;
      end;
    {$I-}
    Close(libr_file) {$I+} ;
    SetSect(HomName)
  end;



  procedure ArcReadDir(var entries     : Word;
                       var space_used  : LongInt;
                       var first       : FilePtr);

  var
    i, x, size      : Integer;
    extname         : name_array;
    This            : FilePtr;
    OK              : Boolean;

  begin                           {ArcReadDir}
    SetSect(SetName);
    Assign(arc_file, ArcReq);
    {$I-}
    Reset(arc_file, 1) {$I+} ;
    if (IoResult = 0) and (FileSize(arc_file) > 0) then
      begin
        while first <> nil do     { Clean out any old directory list }
          begin
            This := first;
            first := first^.next; { Go to next on chain }
            Dispose(This)         { Reclaim space }
          end;
        new_dir := True;
        OK := True;
        ArcSpace := 0;
        ArcEntries := 0;
        while (Read_Arc_Hdr) and OK do
          begin
            in_arc := True;
            FillChar(extname, 11, ' ');
            i := 1;
            x := 1;
            while ((Hdr.name[i-1] <> #0) and (i < 14) and (x < 12)) do
              begin
                if Hdr.name[i-1] = '.' then
                  x := 9
                else
                  begin
                    extname[x] := Ord(Upcase(Hdr.name[i-1]));
                    Inc(x);
                  end;
                Inc(i);
              end;
            if Hdr.size < 128 then
              size := 1
            else if Hdr.size > 4194176 then { maximum file size }
              OK := False
            else
              size := Hdr.size div 128;
            if OK then
              begin
                InsertFile(extname, 0, size, 0, entries, space_used, first);
                {$I-}
                Seek(arc_file, (FilePos(arc_file)+Hdr.size)) {$I+} ;
                OK := (IoResult = 0);
              end;
          end;                    {reading arc file header}
        if (not OK) then
          WriteLn(com, 'Warning! Error reading Arc file ', ArcReq, '.');
      end
    else
      begin
        WriteLn(com, 'Error opening Arc File ', ArcReq, '.');
        new_dir := False;
      end;
    {$I-}
    Close(arc_file) {$I+} ;
    SetSect(HomName);
  end;                            {ArcReadDir}


  function Expand_Filename(tfname : DosFileName) : DosFileName;
    { Expands filename to 12 characters and expands wildcards}

  var
    work_name       : DosFileName;
    n, x, K         : Integer;

  begin
    work_name := '            ';
    work_name[9] := '.';
    x := 1;
    K := 1;
    while (x <= Length(tfname)) and (K < 13) do
      begin
        if tfname[x] = '.' then
          begin
            K := 10;
            Inc(x);
          end;
        if tfname[x] = '*' then
          begin
            if K < 9 then
              begin
                for n := K to 8 do
                  work_name[n] := '?';
                K := 10;
              end
            else
              begin
                if K > 9 then
                  for n := K to 12 do
                    work_name[n] := '?';
                K := 13;
              end;
          end
        else
          work_name[K] := tfname[x];
        Inc(x);
        Inc(K);
      end;
    Expand_Filename := work_name;
  end;



  function Equal_names(test, target : DosFileName) : Boolean;
{ tests equality of two filenames including wildcards expanded
  with the Expand_filename function}

  var
    x               : Integer;
    match           : Boolean;

  begin
    match := True;
    for x := 1 to Length(test) do
      test[x] := Chr($7F and Ord(test[x])); {strip hi bit}
    for x := 1 to Length(target) do
      target[x] := Chr($7F and Ord(target[x])); {strip hi bit}
    x := 1;
    repeat
      if (test[x] <> '?') and (test[x] <> target[x]) then
        match := False;
      Inc(x);
    until (match = False) or (x > Length(test));
    Equal_names := match;
  end;

end.                              { of DIRS.PAS}